( LOAD SCREEN FOR UTILITY IDEOGRAMS MVP-FORTH)111 DUP . LOAD 112 122 THRU 125 LOAD \ STARTING FORTH ADDITIONS 60 LOAD \ EDITOR EXIT ( MVP Utility load screen ) : THRU 1+ SWAP DO I U. I LOAD LOOP ; 2 19 THRU ( now load rest of file ) ( DDUP TITLE 'TITLE TRIAD MVP-FORTH) : DDUP 2DUP ; : DDROP 2DROP ; : TITLE CR 10 SPACES ." MOUNTAIN VIEW PRESS FORTH VERSION 1.0405.03" CR ; VARIABLE 'TITLE ' TITLE CFA 'TITLE ! : TRIAD PAGE 0 3 U/MOD SWAP DROP 3 * 3 OVER + SWAP DO CR I LIST ?TERMINAL IF LEAVE THEN 1 /LOOP 'TITLE @ EXECUTE ; ( \ BMOVE COPY DOVER SWAP MVP-FORTH) : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : BMOVE ROT ROT DDUP U< IF ROT <CMOVE ELSE ROT CMOVE THEN ; : COPY OFFSET @ + SWAP BLOCK 2- ! UPDATE ; : DOVER 4 PICK 4 PICK ; : DSWAP 2SWAP ; \ 4 ROLL 4 ROLL ; ( DU< D- D0= D= D> D@ MVP-FORTH) BASE @ HEX : DU< >R >R 8000 + R> R> 8000 + D< ; BASE ! : D- DNEGATE D+ ; : D0= OR 0= ; : D= D- D0= ; : D> DSWAP D< ; : D@ DUP 2+ @ SWAP @ ; ( DCONSTANT DMAX DMIN MVP-FORTH) : DCONSTANT CREATE , , DOES> DUP 2+ @ SWAP @ ; : DMAX DOVER DOVER D< IF DSWAP THEN DDROP ; : DMIN DOVER DOVER D< NOT IF DSWAP THEN DDROP ; ( .INDEX PAUSE MVP-FORTH) : .INDEX DUP CR 4 .R 2 SPACES BLOCK DISK-ERROR @ IF DROP ELSE C/L -TRAILING TYPE THEN ; : PAUSE ?TERMINAL IF KEY DROP BEGIN ?TERMINAL UNTIL KEY DROP 12000 0 DO LOOP THEN ; ( DUMP-HEADER MVP-FORTH)HEX : DUMP-HEADER CR CR OVER 0F AND ." ADDRESS " DUP 8 0 DO DUP 0F AND 3 .R 1+ LOOP SPACE 8 0 DO DUP 0F AND 3 .R 1+ LOOP DROP 3 SPACES 10 0 DO DUP 0F AND 0 <# # #> TYPE 1+ LOOP DROP CR ; DECIMAL EXIT ( DUMP MVP-FORTH)HEX : DUMP BASE @ >R HEX DUMP-HEADER 0 DO CR DUP I + DUP 0 7 D.R 2 SPACES DUP 8 0 DO DUP I + C@ 3 .R LOOP DROP SPACE DUP 8 + 8 0 DO DUP I + C@ 3 .R LOOP DROP 3 SPACES 10 0 DO DUP I + C@ DUP 20 < OVER 7E > OR IF DROP 2E THEN EMIT LOOP DROP 10 PAUSE ?TERMINAL IF LEAVE THEN /LOOP DROP CR R> BASE ! ; DECIMAL ( DUMPL MVP-FORTH)HEX : DUMPL BASE @ >R HEX DUMP-HEADER 0 DO CR DDUP 9 D.R \ SWAP 0 4 D.R 3A EMIT 0 4 D.R DDUP 8 0 DO DDUP I 0 D+ C@L 3 .R LOOP DDROP SPACE DDUP 8. D+ 8 0 DO DDUP I 0 D+ C@L 3 .R LOOP DDROP 3 SPACES 10 0 DO DDUP I 0 D+ C@L DUP 20 < OVER 7E > OR IF DROP 2E THEN EMIT LOOP 10. D+ 10 PAUSE ?TERMINAL IF LEAVE THEN /LOOP DDROP CR R> BASE ! ; DECIMAL ( DVARIABLE ID. INDEX MVP-FORTH) : DVARIABLE CREATE 4 ALLOT ; : ID. COUNT 31 AND OVER + SWAP DO I C@ 127 AND EMIT LOOP 32 EMIT ; : INDEX CR 1+ SWAP DO I .INDEX PAUSE ?TERMINAL DISK-ERROR @ OR IF LEAVE THEN LOOP ; ( VLIST MVP-FORTH)HEX : VLIST C/L OUT ! CONTEXT @ @ BEGIN C/L OUT @ - OVER C@ 1F AND 4 + < IF CR 0 OUT ! THEN DUP ID. SPACE SPACE PFA 4 - @ DUP NOT PAUSE ?TERMINAL OR UNTIL DROP ; DECIMAL EXIT ( .SS .SL .SR .S MVP-FORTH) -1 CONSTANT .SS \ .S LEFT OR RIGHT SWITCH : .SL 0 ' .SS ! ; \ .S WITH TOP OF STACK ON LEFT : .SR -1 ' .SS ! ; \ .S WITH TOP OF STACK ON RIGHT : .S CR DEPTH IF .SS IF SP@ S0 2- ELSE SP@ S0 SWAP THEN DO I @ 0 D. 2 .SS +- +LOOP ELSE ." EMPTY STACK" THEN CR ; \ SAVE-FORTH constants needed gst850930 create chunk.head \ chunk header in front of image 0 , 1011 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , here 16384 , ( #longs alloc ) 0 , 1001 , 0 , here 0 , ( chunk size ) constant chunk.size \ size of image in long words constant chunk.alloc \ loader to alloc long # of long words \ you can alter this if you want more \ or less than 64k pre allocated \ For example: LIMIT LONGS chunk.alloc ! create chunk.end 0 , 1010 , \ written at end of image \ SAVE-FORTH gst851106: LONGS \ n1 -- n2 | n1 is #bytes n2 is # of long words 3 + 0 4 m/ swap drop ; \ to next full long : SAVE-FORTH FREEZE cr cr ." File Name?" pad 80 expect pad 80 New open 2dup or 0= abort" Open error" ( keep handle ) 0 ColdSwitch ! ( allow saved system to cold ) here 4 + LONGS chunk.size ! \ size in long words chunk.head A>L 2over 32 rot rot write drop \ chunk head 0 A>L ( from ) 4. d- ( a few bytes below forth's 0 ) 2over here 7 + -4 and ( align to longs ) \ dfm dhan len rot rot write drop 2dup \ image now out chunk.end A>L 2over 4 rot rot write drop \ chunk end close 1 ColdSwitch ! ( no cold now ) ; \ other misc. things gst850930 0 CONSTANT FALSE FALSE NOT CONSTANT TRUE ( 'S -TEXT 2! 2@ 2CONSTANT 2DROP 2DUP MVP-FORTH) : 'S SP@ ; : -TEXT DDUP + SWAP DO DROP 1+ DUP 1- C@ I C@ - DUP IF DUP ABS / LEAVE THEN 1 /LOOP SWAP DROP ; \ : 2! D! ; \ : 2@ D@ ; : 2CONSTANT DCONSTANT ; \ : 2DROP DDROP ; \ : 2DUP DDUP ; ( 20VER 2SWAP 2VARIABLE >BINARY > TYPE EMPTY MVP-FORTH) \ : 2OVER DOVER ; \ : 2SWAP DSWAP ; : 2VARIABLE DVARIABLE ; : >BINARY CONVERT ; : >TYPE ." USED IN MULTIPROGRAMMED SYSTEMS ONLY. " ; IMMEDIATE : EMPTY INIT-FORTH @ ' FORTH 2+ ! INIT-USER UP @ 6 + 48 CMOVE ; ( ERASE FLUSH H OCTAL U.R ['] MVP-FORTH) : ERASE 0 FILL ; : FLUSH SAVE-BUFFERS ; : H DP ; : OCTAL 8 BASE ! ; : U.R 0 SWAP D.R ; : ['] ?COMP [COMPILE] ' ; IMMEDIATE
